home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / param.em < prev    next >
Lisp/Scheme  |  1993-07-02  |  4KB  |  132 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: test.em
  4. ;; Date: Mon Apr 19 11:03:33 1993
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;   Sample parameterised classes.
  9. ;;   Really telos abuse, plus example use
  10. ;;   of generic-apply.
  11.  
  12. (defmodule param
  13.   (eulisp0
  14.    scanners
  15.    mixins
  16.    )
  17.   ()
  18.   
  19.   (defun detect (fn lst)
  20.     (if (null lst) nil
  21.       (or (fn (car lst)) 
  22.       (detect fn (cdr lst)))))
  23.  
  24.   ;; Parameterisation. This is mixin abuse. Idea is that 
  25.   ;; (<class> args) gives new parameterised classes. These
  26.   ;; cannot be subclassed.
  27.  
  28.   (defclass <parameterised-class> (<class>)
  29.     ((sigs initform nil accessor parameterised-sigs)
  30.      (superclass accessor parameterised-superclass)
  31.      (meta initform <parameterised-meta> initarg instance-meta reader parameterised-meta)
  32.      (options initform nil initarg instance-metaclass-initargs reader parameterised-initargs))
  33.     metaclass <class>)
  34.  
  35.   (defclass <non-subclassable> ()
  36.     ()
  37.     metaclass <mixin-class>)
  38.  
  39.  (defclass <parameterised> ()
  40.     ((parameters initarg parameters reader parameterised-args))
  41.     metaclass <mixin-class>)
  42.  
  43.  ;; standard parameterised instance 
  44.  (defclass <parameterised-meta> (<non-subclassable> <class>)
  45.    ()
  46.    metaclass <mixin-base-class>)
  47.  
  48.   (defmethod compatible-superclass-p ((cl <class>) (cl <non-subclassable>))
  49.     nil)
  50.  
  51.   (defmethod add-subclass ((cl <non-subclassable>) sub)
  52.     (error "Attempt to subclass non-subclassable class" clock-tick 'error-value cl))
  53.  
  54.   (defmethod initialize ((cl <parameterised-class>) lst)
  55.     (let ((instance-supers (scan-args 'instance-superclasses lst 
  56.                       (default-argument (list <object>))))
  57.       (this-meta (scan-args 'super-meta lst (default-argument <mixin-class>)))
  58.       (cl (call-next-method)))
  59.       ((setter parameterised-superclass) cl 
  60.        (let ((initargs 
  61.           (nconc (list 'direct-superclasses instance-supers
  62.                'direct-slot-descriptions (scan-args 'instance-slot-descriptions lst null-argument)
  63.                'name (make-symbol (format nil "[~a]" (symbol-unbraced-name (class-name cl)))))
  64.              (parameterised-initargs cl))))
  65.      (initialize (allocate this-meta initargs) initargs)))
  66.       cl))
  67.   
  68.   (defun find-parameterised (cl sig)
  69.     (if (null sig) 
  70.     (parameterised-superclass cl)
  71.       (or (lookup-parameterised cl sig)
  72.       (let ((new (make-parameterised cl sig)))
  73.         (add-parameterised cl sig new)
  74.         new))))
  75.  
  76.   (defun lookup-parameterised (cl sig)
  77.     (let ((xx 
  78.        (assoc sig 
  79.           (parameterised-sigs cl)
  80.           equal)))
  81.       (if (null xx) nil (cdr xx))))
  82.  
  83.   (defun make-parameterised (cl sig)
  84.     (let ((initargs (nconc 
  85.              (list 
  86.               'direct-superclasses (list (parameterised-superclass cl))
  87.               'direct-slot-descriptions nil
  88.               'parameters sig
  89.               'name (make-symbol (format nil "~a~a" 
  90.                          (symbol-unbraced-name (class-name cl))
  91.                          (mapcar object-name sig))))
  92.              (parameterised-initargs cl))))
  93.       (initialize (allocate (parameterised-meta cl) initargs) initargs)))
  94.  
  95.   (defgeneric object-name (x)
  96.     method (((x <class>)) (symbol-unbraced-name (class-name x)))
  97.     method (((o <object>)) o)
  98.     method (((fn <generic-function>)) (generic-function-name x)))
  99.  
  100.   (defun add-parameterised (cl sig new)
  101.     ((setter parameterised-sigs) cl 
  102.      (cons (cons sig new) (parameterised-sigs cl))))
  103.  
  104.   ;; Just for entertainment value
  105.   ;; apply creates new parameterised classes
  106.  
  107.   (defmethod generic-apply ((x <parameterised-class>) args)
  108.     (find-parameterised x args))
  109.  
  110.  
  111.     )
  112.  
  113.   
  114.   ;; end module
  115.   )
  116.  
  117. (defclass <H-List> ()
  118.   ()
  119.   metaclass <parameterised-class>
  120.   metaclass-initargs ())
  121.  
  122.  
  123.  
  124.  
  125.  (defclass Polynomial ()
  126.     ()
  127.     metaclass parameterised-class
  128.     metaclass-initargs (instance-meta parameterised-domain-class
  129.             instance-superclasses (list Ring)
  130.             super-meta domain-class
  131.             instance-metaclass-initargs nil)
  132.